home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / PNL Libraries / MyBufferedTCP.p < prev    next >
Encoding:
Text File  |  1993-03-12  |  3.9 KB  |  169 lines  |  [TEXT/PJMM]
  1. unit MyBufferedTCP;
  2.  
  3. interface
  4.  
  5.     uses
  6.         TCPStuff;
  7.  
  8.     type
  9.         TCPBuffer = record
  10.                 tcpc: TCPConnectionPtr;
  11.                 size, count: integer;
  12.                 buffer: Ptr;
  13.             end;
  14.  
  15.     function TBCreate (var buf: TCPBuffer; tcpc: TCPConnectionPtr; buffer_size: integer): OSErr;
  16.     procedure TBDestroy (var buf: TCPBuffer);
  17.     procedure TBReadChars (var buf: TCPBuffer; value: integer);
  18.     function TBGetLongLine (var buf: TCPBuffer; var p: ptr; var len, crlf: integer): boolean;
  19.     procedure TBEatLongLine (var buf: TCPBuffer; len: integer);
  20.     function TBGetLine (var buf: TCPBuffer; var s: str255): boolean;
  21.     function TBTransferTilDot (var buf: TCPBuffer; refnum: integer; var finished: boolean; strip: integer): OSErr;
  22.  
  23. implementation
  24.  
  25.     uses
  26.         MyUtils;
  27.  
  28.     function TBCreate (var buf: TCPBuffer; tcpc: TCPConnectionPtr; buffer_size: integer): OSErr;
  29.     begin
  30.         buf.tcpc := tcpc;
  31.         with buf do begin
  32.             size := buffer_size;
  33.             count := 0;
  34.             buffer := NewPtr(buffer_size);
  35.             TBCreate := MemError;
  36.         end;
  37.     end;
  38.  
  39.     procedure TBDestroy (var buf: TCPBuffer);
  40.     begin
  41.         DisposePtr(buf.buffer);
  42.     end;
  43.  
  44.     procedure TBReadChars (var buf: TCPBuffer; value: integer);
  45.         var
  46.             oe: OSErr;
  47.     begin
  48.         with buf do begin
  49.             if value > size - count then
  50.                 value := size - count;
  51.             if value > 0 then begin
  52.                 oe := TCPRawReceiveChars(tcpc, ptr(ord(buffer) + count), value);
  53.                 if oe = noErr then
  54.                     count := count + value;
  55.             end;
  56.         end;
  57.     end;
  58.  
  59.     function TBGetLongLine (var buf: TCPBuffer; var p: ptr; var len, crlf: integer): boolean;
  60.         var
  61.             q: ptr;
  62.     begin
  63.         TBGetLongLine := false;
  64.         crlf := 0;
  65.         with buf do begin
  66.             p := buffer;
  67.             len := 0;
  68.             q := p;
  69.             while (len < count) & (q^ <> 13) & (q^ <> 10) do begin
  70.                 len := len + 1;
  71.                 longInt(q) := longInt(q) + 1;
  72.             end;
  73.             if (len < count) & (q^ = 13) then begin
  74.                 len := len + 1;
  75.                 crlf := crlf + 1;
  76.                 longInt(q) := longInt(q) + 1;
  77.             end;
  78.             if (len < count) & (q^ = 10) then begin
  79.                 len := len + 1;
  80.                 crlf := crlf + 1;
  81.                 longInt(q) := longInt(q) + 1;
  82.                 TBGetLongLine := true;
  83.             end;
  84.         end;
  85.     end;
  86.  
  87.     procedure TBEatLongLine (var buf: TCPBuffer; len: integer);
  88.     begin
  89.         with buf do begin
  90.             if count = len then begin
  91.                 count := 0;
  92.             end
  93.             else begin
  94.                 BlockMove(ptr(ord(buffer) + len), buffer, count - len);
  95.                 count := count - len;
  96.             end;
  97.         end;
  98.     end;
  99.  
  100.     function TBGetLine (var buf: TCPBuffer; var s: str255): boolean;
  101.         var
  102.             p: ptr;
  103.             len, crlf, l: integer;
  104.     begin
  105.         TBGetLine := false;
  106.         if TBGetLongLine(buf, p, len, crlf) | (len > 512) then begin
  107.             l := len - crlf;
  108.             if l > 255 then
  109.                 l := 255;
  110. {$PUSH}
  111. {$R-}
  112.             s[0] := chr(l);
  113. {$POP}
  114.             if l > 0 then
  115.                 BlockMove(p, @s[1], l);
  116.             TBEatLongLine(buf, len);
  117.             TBGetLine := true;
  118.         end;
  119.     end;
  120.  
  121.     function MyFSStripAndWrite (refnum: integer; len: longInt; p: ptr; strip: integer): OSErr;
  122.         var
  123.             src, dst: ptr;
  124.             i, j: longInt;
  125.     begin
  126.         if strip = 0 then begin
  127.             MyFSStripAndWrite := MyFSWrite(refnum, len, p);
  128.         end
  129.         else begin
  130.             j := 0;
  131.             src := p;
  132.             dst := p;
  133.             for i := 1 to len do begin
  134.                 if src^ <> strip then begin
  135.                     dst^ := src^;
  136.                     dst := ptr(ord(dst) + 1);
  137.                     j := j + 1;
  138.                 end;
  139.                 src := ptr(ord(src) + 1);
  140.             end;
  141.             MyFSStripAndWrite := MyFSWrite(refnum, j, p);
  142.         end;
  143.     end;
  144.  
  145.     function TBTransferTilDot (var buf: TCPBuffer; refnum: integer; var finished: boolean; strip: integer): OSErr;
  146.         var
  147.             p: longInt;
  148.             len: integer;
  149.             oe: OSErr;
  150.     begin
  151.         finished := false;
  152.         oe := noErr;
  153.         with buf do begin
  154.             len := 0;
  155.             p := ord(buffer);
  156.             while (len < count - 4) & ((ptr(p)^ <> 13) | (ptr(p + 2)^ <> ord('.')) | (ptr(p + 3)^ <> 13) | (ptr(p + 1)^ <> 10) | (ptr(p + 4)^ <> 10)) do begin
  157.                 len := len + 1;
  158.                 p := p + 1;
  159.             end;
  160.             finished := (ptr(p)^ = 13) & (ptr(p + 1)^ = 10) & (ptr(p + 2)^ = ord('.')) & (ptr(p + 3)^ = 13) & (ptr(p + 4)^ = 10);
  161.             if finished then
  162.                 len := len + 5;
  163.             oe := MyFSStripAndWrite(refnum, len, buffer, strip);
  164.             TBEatLongLine(buf, len);
  165.         end;
  166.         TBTransferTilDot := oe;
  167.     end;
  168.  
  169. end.